home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / dbf4pas.zip / DEMO4.PAS < prev    next >
Pascal/Delphi Source File  |  1993-01-04  |  5KB  |  169 lines
  1. { This is a short demo of the DBF unit. I didn't have time to make this   }
  2. { readable. So you can see what I had to go through with this guy's code! }
  3.  
  4. program DBF_Demo;
  5.  
  6. uses crt,dbf;
  7. var
  8.   d : dbfrecord;
  9.  
  10. PROCEDURE ErrorHalt(errorCode : Integer);
  11. VAR
  12.   errorMsg : _Str80;
  13. BEGIN
  14.   CASE errorCode OF
  15.     00  : Exit;                { no error occurred }
  16.     $01 : errorMsg := 'Not found';
  17.     $02 : errorMsg := 'Not open for input';
  18.     $03 : errorMsg := 'Not open for output';
  19.     $04 : errorMsg := 'Just not open';
  20.     $91 : errorMsg := 'Seek beyond EOF';
  21.     $99 : errorMsg := 'Unexpected EOF';
  22.     $F0 : errorMsg := 'Disk write error';
  23.     $F1 : errorMsg := 'Directory full';
  24.     $F3 : errorMsg := 'Too many files';
  25.     $FF : errorMsg := 'Where did that file go?';
  26.     NOT_DB_FILE    : errorMsg := 'Not a dBASE data file';
  27.     INVALID_FIELD  : errorMsg := 'Invalid field type encountered';
  28.     REC_TOO_HIGH   : errorMsg := 'Requested record beyond range';
  29.     PARTIAL_READ   : errorMsg := 'Tried to read beyon EOF';
  30.   ELSE
  31.     errorMsg := 'Undefined error';
  32.   END;
  33.   WriteLn;
  34.   WriteLn(errorCode:3, ': ',errorMsg);
  35.   Halt(1);
  36. END;
  37.  
  38. TYPE
  39.   PseudoStr = ARRAY[1..255] OF Char;
  40. VAR
  41.   Demo : dbfRecord;
  42.   j, i : Integer;
  43.   blanks : _Str255;
  44.   SizeOfFile, r : longint;
  45.   fn : _Str64;
  46.  
  47.   PROCEDURE Wait;
  48.   VAR
  49.     c : Char;
  50.   BEGIN
  51.     Write('Press any key to continue . . .');
  52.     repeat
  53.       c := readkey
  54.     until c <> #0
  55.   END;
  56.  
  57.  
  58.   PROCEDURE List(VAR D : dbfRecord);
  59.  
  60.     PROCEDURE ShowField(VAR a; VAR F : _FieldRecord);
  61.     VAR
  62.       Data : PseudoStr ABSOLUTE a;
  63.     BEGIN
  64.       WITH F DO
  65.       BEGIN
  66.         CASE Typ OF
  67.           'C', 'N', 'L' : Write(Copy(Data, 1, Len));
  68.           'M' : Write('Memo      ');
  69.           'D' : Write(Copy(Data, 5, 2), '/',
  70.                 Copy(Data, 7, 2), '/',
  71.                 Copy(Data, 1, 2));
  72.         END;                    {CASE}
  73.         IF Len <= Length(Name) THEN
  74.           Write(Copy(blanks, 1, Length(Name)-Pred(Len)))
  75.         ELSE
  76.           Write(' ');
  77.         END;                    {WITH F}
  78.       END;                      {ShowField}
  79.  
  80.       BEGIN                       {List}
  81.       WriteLn;
  82.       Write('Rec Num  ');
  83.       WITH D DO
  84.         BEGIN
  85.           FOR i := 1 TO NumFields DO
  86.             WITH Fields^[i] DO
  87.               IF Len >= Length(Name) THEN
  88.                 Write(Name, Copy(blanks, 1, Succ(Len-Length(Name))))
  89.               ELSE
  90.                 Write(Name, ' ');
  91.           WriteLn;
  92.           r := 1;
  93.           WHILE r <= NumRecs DO
  94.             BEGIN
  95.               GetDbfRecord(Demo, r);
  96.               IF NOT dbfOK THEN ErrorHalt(dbfError);
  97.               WriteLn;
  98.               Write(r:7, ' ');
  99.               Write(Chr(CurRecord^[0])); { the 'deleted' indicator }
  100.               FOR i := 1 TO NumFields DO
  101.                 ShowField(CurRecord^[Fields^[i].Off], Fields^[i]);
  102.               r := r+1;
  103.             END;                    {WHILE r }
  104.         END;                      {WITH D }
  105.     END;                        {List}
  106.  
  107.   PROCEDURE DisplayStructure(VAR D : dbfRecord);
  108.   VAR
  109.     i : Integer;
  110.   BEGIN
  111.   WITH D DO
  112.     BEGIN
  113.     ClrScr;
  114.     Write(' #  Field Name   Type  Length  Decimal');
  115.     FOR i := 1 TO NumFields DO
  116.       BEGIN
  117.       WITH Fields^[i] DO
  118.         BEGIN
  119.         IF i MOD 20 = 0 THEN
  120.           BEGIN
  121.           WriteLn;
  122.           Wait;
  123.           ClrScr;
  124.           Write(' #  Field Name   Type  Length  Decimal');
  125.           END;
  126.         GoToXY(1, Succ(WhereY));
  127.         Write(i:2, Name:12, Typ:5, Len:9);
  128.         IF Typ = 'N' THEN Write(Dec:5);
  129.         END;                  {WITH Fields^}
  130.       END;                    {FOR}
  131.     WriteLn;
  132.     Wait;
  133.     END;                      {WITH D}
  134.   END;                        { DisplayStructure }
  135.  
  136. BEGIN
  137. WITH Demo DO
  138.   BEGIN
  139.   FillChar(blanks, SizeOf(blanks), $20);
  140.   blanks[0] := Chr(255);
  141.   ClrScr;
  142.   GoToXY(10, 10);
  143.   Write('Name of dBASE file (.DBF assumed): ');
  144.   Read(FileName);
  145.   IF Pos('.', FileName) = 0 THEN FileName := FileName+'.DBF';
  146.   OpenDbf(Demo);
  147.   IF NOT dbfOK THEN ErrorHalt(dbfError);
  148.   ClrScr;
  149.   SizeOfFile := FileSize(dFile);
  150.   WriteLn('File Name: ', FileName);
  151.   WriteLn('Date Of Last Update: ', DateOfUpdate);
  152.   WriteLn('Number of Records: ', NumRecs:10);
  153.   WriteLn('Size of File: ', SizeOfFile:15);
  154.   WriteLn('Length of Header: ', HeadLen:11);
  155.   WriteLn('Length of One Record: ', RecLen:7);
  156.   IF WithMemo THEN WriteLn('This file contains Memo fields.');
  157.   IF HeadProlog[0] = DB2File THEN WriteLn('dBASE 2.4 file');
  158.   Wait;
  159.   ClrScr;
  160.   DisplayStructure(Demo);
  161.   ClrScr;
  162.   List(Demo);
  163.   WriteLn;
  164.   Wait;
  165.   CloseDbf(Demo);
  166.   IF NOT dbfOK THEN ErrorHalt(dbfError);
  167.   END;
  168. END.
  169.